home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
ada
/
gwuada_9.zip
/
3B.C
< prev
next >
Wrap
C/C++ Source or Header
|
1993-07-27
|
57KB
|
1,849 lines
/*
* Copyright (C) 1985-1992 New York University
*
* This file is part of the Ada/Ed-C system. See the Ada/Ed README file for
* warranty (none) and distribution info and also the GNU General Public
* License for more details.
*/
#include "3.h"
#include "attr.h"
#include "setp.h"
#include "dclmapp.h"
#include "errmsgp.h"
#include "evalp.h"
#include "nodesp.h"
#include "miscp.h"
#include "smiscp.h"
#include "chapp.h"
static void new_unconstrained_array(Symbol, Node);
static Symbol constrain_index(Symbol, Node);
static void discr_decl(Node);
static Tuple process_anons(Tuple);
static int reformat_requires(Node);
Tuple apply_range(Node range_expr) /*;apply_range*/
{
/* A'RANGE is equivalent to A'FIRST..A'LAST. When the range attribute
* is used as a constraint, the bounds are expressed according to the
* above equivalence. This is not strictly correct if the elaboration
* of A has side-effects, but we ignore this detail for now.
*/
Node attr, arg1, arg2;
Tuple new_c;
Node l_node, f_node;
int f, l, attr_kind;
if (N_KIND(range_expr) == as_qual_range)
/* discard spurious constraint. */
range_expr = N_AST1(range_expr);
attr = N_AST1(range_expr);
arg1 = N_AST2(range_expr);
arg2 = N_AST3(range_expr);
/* The attribute is either O_RANGE or T_RANGE, according as arg1 is an
* object or a type. FIRST and LAST must be marked accordingly.
*/
/* In C note that base attribute kind followed by O_ kind, then T_. */
attr_kind = (int) attribute_kind(range_expr);
if (attr_kind == ATTR_O_RANGE) {
f = ATTR_O_FIRST;
l = ATTR_O_LAST;
}
else {
f = ATTR_T_FIRST;
l = ATTR_T_LAST;
}
f_node = new_attribute_node(f, arg1, arg2, N_TYPE(range_expr));
l_node = new_attribute_node(l, copy_tree(arg1), copy_tree(arg2),
N_TYPE(range_expr));
N_KIND(range_expr) = as_range;
N_AST1(range_expr) = f_node;
N_AST2(range_expr) = l_node;
/*return ?? ['range', f_node, l_node];*/
new_c = constraint_new(CONSTRAINT_RANGE);
numeric_constraint_low(new_c) = (char *) f_node;
numeric_constraint_high(new_c) = (char *) l_node;
return new_c;
}
void array_typedef(Node node) /*;array_typedef*/
{
Node index_list_node, type_indic_node;
Tuple index_nodes;
Node indx_node, indx1_node;
Tuple index_type_list;
Symbol element_type;
int i, exists;
Fortup ft1;
if (cdebug2 > 3) TO_ERRFILE("AT PROC : array_typedef");
index_list_node = N_AST1(node);
type_indic_node = N_AST2(node);
sem_list(index_list_node);
index_nodes = N_LIST(index_list_node);
index_type_list = tup_new(tup_size(index_nodes));
FORTUPI(indx_node =(Node), index_nodes, i, ft1);
index_type_list[i] = (char *) make_index(indx_node);
ENDFORTUP(ft1);
adasem(type_indic_node);
element_type = promote_subtype(make_subtype(type_indic_node));
/* Validate an array type definition.*/
exists = FALSE;
FORTUP(indx_node =(Node) , index_nodes, ft1);
if (N_KIND(indx_node) == as_box) {
exists = TRUE;
break;
}
ENDFORTUP(ft1);
if (exists) {
exists = FALSE;
/*Unconstrained array . Verify that all indices are unconstrained.*/
FORTUP(indx1_node = (Node), index_nodes, ft1);
if (N_KIND(indx1_node) != as_box) {
exists = TRUE;
break;
}
ENDFORTUP(ft1);
if (exists) {
errmsg("Constraints apply to all indices or none", "3.6.1", node);
}
}
if (is_unconstrained(element_type)) {
errmsg("Unconstrained element type in array declaration",
"3.6.1, 3.7.2", type_indic_node);
}
check_fully_declared2(element_type);
for (i = 1; i<= tup_size(index_nodes); i++) {
Node tmp = (Node) index_nodes[i];
N_UNQ(tmp) = (Symbol) (index_type_list[i]);
}
N_UNQ(type_indic_node) = element_type;
}
void new_array_type(Symbol array_type, Node def_node) /*;new_array_type*/
{
/* This procedure is called whenever an array type is created.
* For each new array type we create a corresponding sequence type,
* which is an unconstrained array. Unconstrained array types have
* nature na_array, while constrained arrays have nature na_subtype.
*/
Node index_list_node;
Tuple tn;
Node tnn;
if (cdebug2 > 3) TO_ERRFILE("AT PROC : new_array_type(array_type");
adasem(def_node);
index_list_node = N_AST1(def_node);
tn = N_LIST(index_list_node);
tnn = (Node) tn[1];
if (N_KIND(tnn) == as_box)
/* Unconstrained array definition. In this case, introduce only the*/
/* unconstrained type, and ignore the actual array type.*/
new_unconstrained_array(array_type, def_node);
else
new_constrained_array(array_type, def_node);
}
static void new_unconstrained_array(Symbol sequence_type, Node def_node)
/*;new_unconstrained_array*/
{
Node index_list_node, type_indic_node, indx_node;
Fortup ft1;
int i, l;
Tuple index_list, array_info;
Symbol comp;
index_list_node= N_AST1(def_node);
type_indic_node = N_AST2(def_node);
/*index_list := [N_UNQ(indx_node) : indx_node in N_LIST(index_list_node)];*/
index_list = tup_new(tup_size(N_LIST(index_list_node)));
FORTUPI(indx_node=(Node), N_LIST(index_list_node), i, ft1);
index_list[i] = (char *) N_UNQ(indx_node);
ENDFORTUP(ft1);
/*??array_info := [index_list, N_UNQ(type_indic_node)];*/
array_info = tup_new(2);
array_info[1] = (char *) index_list;
comp = N_UNQ(type_indic_node);
array_info[2] = (char *) comp;
/*SYMBTAB(sequence_type) := [na_array, sequence_type, array_info];*/
NATURE(sequence_type) = na_array;
TYPE_OF(sequence_type) = sequence_type;
SIGNATURE(sequence_type) = array_info;
/*Mark the type as limited if the component type is.*/
if (is_access(comp))
misc_type_attributes(sequence_type) = 0;
else {
l= (int) private_kind(comp);
misc_type_attributes(sequence_type) = l;
}
root_type(sequence_type) = sequence_type;
initialize_representation_info(sequence_type,TAG_ARRAY);
/* For each unconstrained array type, we introduce an instance of the
* 'aggregate' pseudo-operator for that array.
*/
new_agg_or_access_agg(sequence_type);
}
void new_constrained_array(Symbol array_type, Node def_node)
/*;new_constrained_array*/
{
char *nam;
Fortup ft1;
Symbol sequence_type;
Tuple t, index_list, array_info;
Node index_list_node, type_indic_node, indx_node;
int i;
char *sequence_type_name;
/* Construct meaningful name for anonymous parent type.*/
nam = original_name(array_type);
if (strcmp(nam , "") == 0) nam = "anonymous_array";
sequence_type_name = strjoin(nam , strjoin("\'base" , newat_str()));
sequence_type = sym_new(na_void);
dcl_put(DECLARED(scope_name), sequence_type_name, sequence_type);
SCOPE_OF(sequence_type) = SCOPE_OF(array_type);
/* emit sequence type as an anonymous type. It is used in aggregates
* that are assigned to slices, and in other unconstrained contexts.
* (This should only be needed for one dimensional arrays).
*/
/*top(NEWTYPES) with:= sequence_type;*/
t = (Tuple) newtypes[tup_size(newtypes)];
t = tup_with(t, (char *) sequence_type);
newtypes[tup_size(newtypes)] = (char *) t;
new_unconstrained_array(sequence_type, def_node);
/* Make the actual array type into a subtype of the unconstrained one*/
index_list_node = N_AST1(def_node);
type_indic_node = N_AST2(def_node);
index_list = tup_new(tup_size(N_LIST(index_list_node)));
FORTUPI(indx_node = (Node), N_LIST(index_list_node), i, ft1);
index_list[i] = (char *) N_UNQ(indx_node);
ENDFORTUP(ft1);
/*array_info := [index_list, N_UNQ(type_indic_node)];*/
array_info = tup_new(2);
array_info[1] = (char *) index_list;
array_info[2] = (char *) N_UNQ(type_indic_node);
/*??SYMBTAB(array_type) = [na_subtype, sequence_type, array_info];*/
NATURE(array_type) = na_subtype;
TYPE_OF(array_type) = sequence_type;
SIGNATURE(array_type) = array_info;
misc_type_attributes(array_type) = misc_type_attributes(sequence_type);
root_type(array_type) = sequence_type;
}
Symbol anonymous_array(Node node) /*;anonymous_array*/
{
/* Process an array definition in an object or constant declaration.
* The node is an array_type node.
*/
Symbol typ;
Tuple t;
if (cdebug2 > 3) TO_ERRFILE("AT PROC : anonymous_array");
typ = find_new(strjoin("anon", newat_str())); /*Create a name for it*/
new_array_type(typ, node); /*elaborate definition*/
/*??top(NEWTYPES) with